home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Modules / pretty.em < prev    next >
Lisp/Scheme  |  1993-07-09  |  3KB  |  96 lines
  1. ;; Eulisp Module
  2. ;; Author: pab
  3. ;; File: pretty.em
  4. ;; Date: Fri Jul  9 12:28:15 1993
  5. ;;
  6. ;; Project:
  7. ;; Description: 
  8. ;;  pretty printing for lists. Not defuns.
  9.  
  10. (defmodule pretty
  11.   (eulisp0         
  12.    )
  13.   ()
  14.     
  15.   (defstruct <tracking-stream> ()
  16.     ((stream initarg stream reader tracking-stream-stream)
  17.      (pos initform 0 accessor tracking-stream-pos)
  18.      (lst initform nil accessor tlst))
  19.     constructor (make-tracking-stream stream))
  20.  
  21.   (defun inc-posn (stream n)
  22.     ((setter tracking-stream-pos) stream
  23.      (+ n (tracking-stream-pos stream))))
  24.   
  25.   (defun zero-posn (stream)
  26.     ((setter tracking-stream-pos) stream 0))
  27.  
  28.   (defmethod output ((stream <tracking-stream>) (o <character>))
  29.     (if (eq o #\newline)
  30.     (zero-posn stream)
  31.       (inc-posn stream 1))
  32.     ((setter tlst) stream (cons o (tlst stream)))
  33.     (output (tracking-stream-stream stream) o)
  34.     o)
  35.  
  36.   ;; much too lazy---should really
  37.   ;; check for newlines in here too 
  38.   ;; may be better to have line-buffering though.
  39.   (defmethod output ((stream <tracking-stream>) (s <string>))
  40.     (do (lambda (c)
  41.       (output stream c))
  42.     s))
  43.   
  44.   (defmethod flush ((stream <tracking-stream>))
  45.     (flush (tracking-stream-stream stream)))
  46.  
  47.   ;; pretty printer
  48.   (defconstant *width* 60)
  49.   
  50.   (defun pretty-print (form . stream)
  51.     (let ((stream (make-tracking-stream
  52.            (if (null stream)
  53.                (standard-output-stream)
  54.              (car stream)))))
  55.       (newline stream)
  56.       (pp-aux form 0 stream)))
  57.   
  58.   (defconstant pp pretty-print)
  59.  
  60.   (defgeneric pp-aux (form off stream))
  61.   
  62.   (defmethod pp-aux ((x <object>) off stream)
  63.     (generic-write x stream))
  64.   
  65.   ;; Utterly broken quick hack
  66.   (defmethod pp-aux ((form <pair>) off stream)
  67.     (if (not (consp (car form)))
  68.         (progn (newline stream)
  69.                (generic-prin (make-string off) stream))
  70.       nil)
  71.   (generic-prin "(" stream)
  72.     (let ((here (tracking-stream-pos stream)))
  73.       (labels ((aux (forms )
  74.             (if (consp forms)
  75.             (progn (pp-aux (car forms) here stream)
  76.                    (when (consp (cdr forms)) (generic-prin " " stream))
  77.                    (if (> (tracking-stream-pos stream) *width*)
  78.                    (skip-down-to here)
  79.                  nil)
  80.                    (aux (cdr forms)))
  81.               (if (null forms)
  82.               nil
  83.             (progn (if (> (tracking-stream-pos stream) (- *width* 3))
  84.                    (skip-down-to here)
  85.                  nil)
  86.                    (generic-prin " . " stream)
  87.                    (pp-aux forms here stream)))))
  88.            (skip-down-to (x)
  89.                  (progn (newline stream)
  90.                     (generic-prin (make-string x) stream))))
  91.           (aux form)
  92.           (generic-prin ")" stream))))
  93.   
  94.   ;; end module
  95.   )
  96.